home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / scaexpp < prev    next >
Text File  |  1993-03-25  |  39KB  |  2,942 lines
  1. ;;; This file was munged by a simple minded sed script since it left
  2. ;;; its original authors' hands.  See syncase.doc for the horrid details.
  3.  
  4. (begin ((lambda ()
  5. (letrec ((lambda-var-list (lambda (vars)
  6. ((letrec ((lvl (lambda (vars ls)
  7. (if (pair? vars)
  8. (lvl (cdr vars)
  9. (cons (car vars)
  10. ls))
  11. (if (id? vars)
  12. (cons vars
  13. ls)
  14. (if (null?
  15. vars)
  16. ls
  17. (if (syntax-object?
  18. vars)
  19. (lvl (unwrap
  20. vars)
  21. ls)
  22. (cons vars
  23. ls))))))))
  24. lvl)
  25. vars
  26. '())))
  27. (gen-var (lambda (id) (gen-sym (id-sym-name id))))
  28. (gen-sym (lambda (sym)
  29. (syncase:new-symbol-hook (symbol->string sym))))
  30. (strip (lambda (x)
  31. (if (syntax-object? x)
  32. (strip (syntax-object-expression x))
  33. (if (pair? x)
  34. ((lambda (a d)
  35. (if (if (eq? a (car x))
  36. (eq? d (cdr x))
  37. #f)
  38. x
  39. (cons a d)))
  40. (strip (car x))
  41. (strip (cdr x)))
  42. (if (vector? x)
  43. ((lambda (old)
  44. ((lambda (new)
  45. (if (syncase:andmap eq? old new)
  46. x
  47. (list->vector new)))
  48. (map strip old)))
  49. (vector->list x))
  50. x)))))
  51. (regen (lambda (x)
  52. ((lambda (g000139)
  53. (if (memv g000139 '(ref))
  54. (syncase:build-lexical-reference (cadr x))
  55. (if (memv g000139 '(primitive))
  56. (syncase:build-global-reference (cadr x))
  57. (if (memv g000139 '(id))
  58. (syncase:build-identifier (cadr x))
  59. (if (memv g000139 '(quote))
  60. (syncase:build-data (cadr x))
  61. (if (memv
  62. g000139
  63. '(lambda))
  64. (syncase:build-lambda
  65. (cadr x)
  66. (regen (caddr x)))
  67. (begin g000139
  68. (syncase:build-application
  69. (syncase:build-global-reference
  70. (car x))
  71. (map regen
  72. (cdr x))))))))))
  73. (car x))))
  74. (gen-vector (lambda (x)
  75. (if (eq? (car x) 'list)
  76. (syncase:list* 'vector (cdr x))
  77. (if (eq? (car x) 'quote)
  78. (list
  79. 'quote
  80. (list->vector (cadr x)))
  81. (list 'list->vector x)))))
  82. (gen-append (lambda (x y)
  83. (if (equal? y ''())
  84. x
  85. (list 'append x y))))
  86. (gen-cons (lambda (x y)
  87. (if (eq? (car y) 'list)
  88. (syncase:list* 'list x (cdr y))
  89. (if (if (eq? (car x) 'quote)
  90. (eq? (car y) 'quote)
  91. #f)
  92. (list
  93. 'quote
  94. (cons (cadr x) (cadr y)))
  95. (if (equal? y ''())
  96. (list 'list x)
  97. (list 'cons x y))))))
  98. (gen-map (lambda (e map-env)
  99. ((lambda (formals actuals)
  100. (if (eq? (car e) 'ref)
  101. (car actuals)
  102. (if (syncase:andmap
  103. (lambda (x)
  104. (if (eq? (car x) 'ref)
  105. (memq (cadr x)
  106. formals)
  107. #f))
  108. (cdr e))
  109. (syncase:list*
  110. 'map
  111. (list 'primitive (car e))
  112. (map ((lambda (r)
  113. (lambda (x)
  114. (cdr (assq (cadr x)
  115. r))))
  116. (map cons
  117. formals
  118. actuals))
  119. (cdr e)))
  120. (syncase:list*
  121. 'map
  122. (list 'lambda formals e)
  123. actuals))))
  124. (map cdr map-env)
  125. (map (lambda (x) (list 'ref (car x)))
  126. map-env))))
  127. (gen-ref (lambda (var level maps k)
  128. (if (= level 0)
  129. (k var maps)
  130. (gen-ref
  131. var
  132. (- level 1)
  133. (cdr maps)
  134. (lambda (outer-var outer-maps)
  135. ((lambda (b)
  136. (if b
  137. (k (cdr b) maps)
  138. ((lambda (inner-var)
  139. (k inner-var
  140. (cons (cons (cons outer-var
  141. inner-var)
  142. (car maps))
  143. outer-maps)))
  144. (gen-sym var))))
  145. (assq outer-var (car maps))))))))
  146. (chi-syntax (lambda (src exp r w)
  147. ((letrec ((gen (lambda (e maps k)
  148. (if (id? e)
  149. ((lambda (n)
  150. ((lambda (b)
  151. (if (eq? (binding-type
  152. b)
  153. 'syntax)
  154. ((lambda (level)
  155. (if (< (length
  156. maps)
  157. level)
  158. (syntax-error
  159. src
  160. "missing ellipsis in")
  161. (gen-ref
  162. n
  163. level
  164. maps
  165. (lambda (x
  166. maps)
  167. (k (list
  168. 'ref
  169. x)
  170. maps)))))
  171. (binding-value
  172. b))
  173. (if (ellipsis?
  174. (wrap e
  175. w))
  176. (syntax-error
  177. src
  178. "invalid context for ... in")
  179. (k (list
  180. 'id
  181. (wrap e
  182. w))
  183. maps))))
  184. (lookup
  185. n
  186. e
  187. r)))
  188. (id-var-name
  189. e
  190. w))
  191. ((lambda (g000141)
  192. ((lambda (g000142)
  193. ((lambda (g000140)
  194. (if (not (eq? g000140
  195. 'no))
  196. ((lambda (_dots1
  197. _dots2)
  198. (if (if (ellipsis?
  199. (wrap _dots1
  200. w))
  201. (ellipsis?
  202. (wrap _dots2
  203. w))
  204. #f)
  205. (k (list
  206. 'id
  207. (wrap _dots1
  208. w))
  209. maps)
  210. (g000142)))
  211. (car g000140)
  212. (cadr g000140))
  213. (g000142)))
  214. (syntax-dispatch
  215. g000141
  216. '(pair (any)
  217. pair
  218. (any)
  219. atom)
  220. (vector))))
  221. (lambda ()
  222. ((lambda (g000144)
  223. ((lambda (g000145)
  224. ((lambda (g000143)
  225. (if (not (eq? g000143
  226. 'no))
  227. ((lambda (_x
  228. _dots
  229. _y)
  230. (if (ellipsis?
  231. (wrap _dots
  232. w))
  233. (gen _y
  234. maps
  235. (lambda (y
  236. maps)
  237. (gen _x
  238. (cons '()
  239. maps)
  240. (lambda (x
  241. maps)
  242. (if (null?
  243. (car maps))
  244. (syntax-error
  245. src
  246. "extra ellipsis in")
  247. (k (gen-append
  248. (gen-map
  249. x
  250. (car maps))
  251. y)
  252. (cdr maps)))))))
  253. (g000145)))
  254. (car g000143)
  255. (cadr g000143)
  256. (caddr
  257. g000143))
  258. (g000145)))
  259. (syntax-dispatch
  260. g000144
  261. '(pair (any)
  262. pair
  263. (any)
  264. any)
  265. (vector))))
  266. (lambda ()
  267. ((lambda (g000147)
  268. ((lambda (g000146)
  269. (if (not (eq? g000146
  270. 'no))
  271. ((lambda (_x
  272. _y)
  273. (gen _x
  274. maps
  275. (lambda (x
  276. maps)
  277. (gen _y
  278. maps
  279. (lambda (y
  280. maps)
  281. (k (gen-cons
  282. x
  283. y)
  284. maps))))))
  285. (car g000146)
  286. (cadr g000146))
  287. ((lambda (g000149)
  288. ((lambda (g000148)
  289. (if (not (eq? g000148
  290. 'no))
  291. ((lambda (_e1
  292. _e2)
  293. (gen (cons _e1
  294. _e2)
  295. maps
  296. (lambda (e
  297. maps)
  298. (k (gen-vector
  299. e)
  300. maps))))
  301. (car g000148)
  302. (cadr g000148))
  303. ((lambda (g000151)
  304. ((lambda (g000150)
  305. (if (not (eq? g000150
  306. 'no))
  307. ((lambda (__)
  308. (k (list
  309. 'quote
  310. (wrap e
  311. w))
  312. maps))
  313. (car g000150))
  314. (syntax-error
  315. g000151)))
  316. (syntax-dispatch
  317. g000151
  318. '(any)
  319. (vector))))
  320. g000149)))
  321. (syntax-dispatch
  322. g000149
  323. '(vector
  324. pair
  325. (any)
  326. each
  327. any)
  328. (vector))))
  329. g000147)))
  330. (syntax-dispatch
  331. g000147
  332. '(pair (any)
  333. any)
  334. (vector))))
  335. g000144))))
  336. g000141))))
  337. e)))))
  338. gen)
  339. exp
  340. '()
  341. (lambda (e maps) (regen e)))))
  342. (ellipsis? (lambda (x)
  343. ;; I dont know what this is supposed to do, and removing it seemed harmless.
  344. ;; (if (if (top-level-bound? 'dp) dp #f)
  345. ;; (break)
  346. ;; (syncase:void))
  347. (if (identifier? x)
  348. (free-id=? x '...)
  349. #f)))
  350. (chi-syntax-definition (lambda (e w)
  351. ((lambda (g000153)
  352. ((lambda (g000154)
  353. ((lambda (g000152)
  354. (if (not (eq? g000152
  355. 'no))
  356. ((lambda (__
  357. _name
  358. _val)
  359. (if (id? _name)
  360. (list _name
  361. _val)
  362. (g000154)))
  363. (car g000152)
  364. (cadr g000152)
  365. (caddr
  366. g000152))
  367. (g000154)))
  368. (syntax-dispatch
  369. g000153
  370. '(pair (any)
  371. pair
  372. (any)
  373. pair
  374. (any)
  375. atom)
  376. (vector))))
  377. (lambda ()
  378. (syntax-error
  379. g000153))))
  380. (wrap e w))))
  381. (chi-definition (lambda (e w)
  382. ((lambda (g000156)
  383. ((lambda (g000157)
  384. ((lambda (g000155)
  385. (if (not (eq? g000155
  386. 'no))
  387. (apply
  388. (lambda (__
  389. _name
  390. _args
  391. _e1
  392. _e2)
  393. (if (if (id? _name)
  394. (valid-bound-ids?
  395. (lambda-var-list
  396. _args))
  397. #f)
  398. (list _name
  399. (cons '#(syntax-object
  400. lambda
  401. (top))
  402. (cons _args
  403. (cons _e1
  404. _e2))))
  405. (g000157)))
  406. g000155)
  407. (g000157)))
  408. (syntax-dispatch
  409. g000156
  410. '(pair (any)
  411. pair
  412. (pair (any) any)
  413. pair
  414. (any)
  415. each
  416. any)
  417. (vector))))
  418. (lambda ()
  419. ((lambda (g000159)
  420. ((lambda (g000158)
  421. (if (not (eq? g000158
  422. 'no))
  423. ((lambda (__
  424. _name
  425. _val)
  426. (list _name
  427. _val))
  428. (car g000158)
  429. (cadr g000158)
  430. (caddr
  431. g000158))
  432. ((lambda (g000161)
  433. ((lambda (g000162)
  434. ((lambda (g000160)
  435. (if (not (eq? g000160
  436. 'no))
  437. ((lambda (__
  438. _name)
  439. (if (id? _name)
  440. (list _name
  441. (list '#(syntax-object
  442. syncase:void
  443. (top))))
  444. (g000162)))
  445. (car g000160)
  446. (cadr g000160))
  447. (g000162)))
  448. (syntax-dispatch
  449. g000161
  450. '(pair (any)
  451. pair
  452. (any)
  453. atom)
  454. (vector))))
  455. (lambda ()
  456. (syntax-error
  457. g000161))))
  458. g000159)))
  459. (syntax-dispatch
  460. g000159
  461. '(pair (any)
  462. pair
  463. (any)
  464. pair
  465. (any)
  466. atom)
  467. (vector))))
  468. g000156))))
  469. (wrap e w))))
  470. (chi-sequence (lambda (e w)
  471. ((lambda (g000164)
  472. ((lambda (g000163)
  473. (if (not (eq? g000163 'no))
  474. ((lambda (__ _e) _e)
  475. (car g000163)
  476. (cadr g000163))
  477. (syntax-error g000164)))
  478. (syntax-dispatch
  479. g000164
  480. '(pair (any) each any)
  481. (vector))))
  482. (wrap e w))))
  483. (chi-macro-def (lambda (def r w)
  484. (syncase:eval-hook (chi def null-env w))))
  485. (chi-local-syntax (lambda (e r w)
  486. ((lambda (g000166)
  487. ((lambda (g000167)
  488. ((lambda (g000165)
  489. (if (not (eq? g000165
  490. 'no))
  491. (apply
  492. (lambda (_who
  493. _var
  494. _val
  495. _e1
  496. _e2)
  497. (if (valid-bound-ids?
  498. _var)
  499. ((lambda (new-vars)
  500. ((lambda (new-w)
  501. (chi-body
  502. (cons _e1
  503. _e2)
  504. e
  505. (extend-macro-env
  506. new-vars
  507. ((lambda (w)
  508. (map (lambda (x)
  509. (chi-macro-def
  510. x
  511. r
  512. w))
  513. _val))
  514. (if (free-id=?
  515. _who
  516. '#(syntax-object
  517. letrec-syntax
  518. (top)))
  519. new-w
  520. w))
  521. r)
  522. new-w))
  523. (make-binding-wrap
  524. _var
  525. new-vars
  526. w)))
  527. (map gen-var
  528. _var))
  529. (g000167)))
  530. g000165)
  531. (g000167)))
  532. (syntax-dispatch
  533. g000166
  534. '(pair (any)
  535. pair
  536. (each pair
  537. (any)
  538. pair
  539. (any)
  540. atom)
  541. pair
  542. (any)
  543. each
  544. any)
  545. (vector))))
  546. (lambda ()
  547. ((lambda (g000169)
  548. ((lambda (g000168)
  549. (if (not (eq? g000168
  550. 'no))
  551. ((lambda (__)
  552. (syntax-error
  553. (wrap e
  554. w)))
  555. (car g000168))
  556. (syntax-error
  557. g000169)))
  558. (syntax-dispatch
  559. g000169
  560. '(any)
  561. (vector))))
  562. g000166))))
  563. e)))
  564. (chi-body (lambda (body source r w)
  565. (if (null? (cdr body))
  566. (chi (car body) r w)
  567. ((letrec ((parse1 (lambda (body
  568. var-ids
  569. var-vals
  570. macro-ids
  571. macro-vals)
  572. (if (null? body)
  573. (syntax-error
  574. (wrap source
  575. w)
  576. "no expressions in body")
  577. ((letrec ((parse2 (lambda (e)
  578. ((lambda (b)
  579. ((lambda (g000170)
  580. (if (memv
  581. g000170
  582. '(macro))
  583. (parse2
  584. (chi-macro
  585. (binding-value
  586. b)
  587. e
  588. r
  589. empty-wrap
  590. (lambda (e
  591. r
  592. w)
  593. (wrap e
  594. w))))
  595. (if (memv
  596. g000170
  597. '(definition))
  598. (parse1
  599. (cdr body)
  600. (cons (cadr b)
  601. var-ids)
  602. (cons (caddr
  603. b)
  604. var-vals)
  605. macro-ids
  606. macro-vals)
  607. (if (memv
  608. g000170
  609. '(syntax-definition))
  610. (parse1
  611. (cdr body)
  612. var-ids
  613. var-vals
  614. (cons (cadr b)
  615. macro-ids)
  616. (cons (caddr
  617. b)
  618. macro-vals))
  619. (if (memv
  620. g000170
  621. '(sequence))
  622. (parse1
  623. (append
  624. (cdr b)
  625. (cdr body))
  626. var-ids
  627. var-vals
  628. macro-ids
  629. macro-vals)
  630. (begin g000170
  631. (if (valid-bound-ids?
  632. (append
  633. var-ids
  634. macro-ids))
  635. ((lambda (new-var-names
  636. new-macro-names)
  637. ((lambda (w)
  638. ((lambda (r)
  639. (syncase:build-letrec
  640. new-var-names
  641. (map (lambda (x)
  642. (chi x
  643. r
  644. w))
  645. var-vals)
  646. (syncase:build-sequence
  647. (map (lambda (x)
  648. (chi x
  649. r
  650. w))
  651. body))))
  652. (extend-macro-env
  653. new-macro-names
  654. (map (lambda (x)
  655. (chi-macro-def
  656. x
  657. r
  658. w))
  659. macro-vals)
  660. (extend-var-env
  661. new-var-names
  662. r))))
  663. (make-binding-wrap
  664. (append
  665. macro-ids
  666. var-ids)
  667. (append
  668. new-macro-names
  669. new-var-names)
  670. empty-wrap)))
  671. (map gen-var
  672. var-ids)
  673. (map gen-var
  674. macro-ids))
  675. (syntax-error
  676. (wrap source
  677. w)
  678. "invalid identifier"))))))))
  679. (car b)))
  680. (syntax-type
  681. e
  682. r
  683. empty-wrap)))))
  684. parse2)
  685. (car body))))))
  686. parse1)
  687. (map (lambda (x) (wrap x w)) body)
  688. '()
  689. '()
  690. '()
  691. '()))))
  692. (syntax-type (lambda (e r w)
  693. (if (syntax-object? e)
  694. (syntax-type
  695. (syntax-object-expression e)
  696. r
  697. (join-wraps
  698. (syntax-object-wrap e)
  699. w))
  700. (if (if (pair? e)
  701. (identifier? (car e))
  702. #f)
  703. ((lambda (n)
  704. ((lambda (b)
  705. ((lambda (g000171)
  706. (if (memv
  707. g000171
  708. '(special))
  709. (if (memv
  710. n
  711. '(define))
  712. (cons 'definition
  713. (chi-definition
  714. e
  715. w))
  716. (if (memv
  717. n
  718. '(define-syntax))
  719. (cons 'syntax-definition
  720. (chi-syntax-definition
  721. e
  722. w))
  723. (if (memv
  724. n
  725. '(begin))
  726. (cons 'sequence
  727. (chi-sequence
  728. e
  729. w))
  730. (begin n
  731. (syncase:void)))))
  732. (begin g000171
  733. b)))
  734. (binding-type b)))
  735. (lookup n (car e) r)))
  736. (id-var-name (car e) w))
  737. '(other)))))
  738. (chi-args (lambda (args r w source source-w)
  739. (if (pair? args)
  740. (cons (chi (car args) r w)
  741. (chi-args
  742. (cdr args)
  743. r
  744. w
  745. source
  746. source-w))
  747. (if (null? args)
  748. '()
  749. (if (syntax-object? args)
  750. (chi-args
  751. (syntax-object-expression
  752. args)
  753. r
  754. (join-wraps
  755. w
  756. (syntax-object-wrap
  757. args))
  758. source
  759. source-w)
  760. (syntax-error
  761. (wrap source source-w)))))))
  762. (chi-ref (lambda (e name binding w)
  763. ((lambda (g000172)
  764. (if (memv g000172 '(lexical))
  765. (syncase:build-lexical-reference name)
  766. (if (memv
  767. g000172
  768. '(global global-unbound))
  769. (syncase:build-global-reference name)
  770. (begin g000172
  771. (id-error
  772. (wrap e w))))))
  773. (binding-type binding))))
  774. (chi-macro (letrec ((check-macro-output (lambda (x)
  775. (if (pair?
  776. x)
  777. (begin (check-macro-output
  778. (car x))
  779. (check-macro-output
  780. (cdr x)))
  781. ((lambda (g000173)
  782. (if g000173
  783. g000173
  784. (if (vector?
  785. x)
  786. ((lambda (n)
  787. ((letrec ((g000174 (lambda (i)
  788. (if (= i
  789. n)
  790. (syncase:void)
  791. (begin (check-macro-output
  792. (vector-ref
  793. x
  794. i))
  795. (g000174
  796. (+ i
  797. 1)))))))
  798. g000174)
  799. 0))
  800. (vector-length
  801. x))
  802. (if (symbol?
  803. x)
  804. (syntax-error
  805. x
  806. "encountered raw symbol")
  807. (syncase:void)))))
  808. (syntax-object?
  809. x))))))
  810. (lambda (p e r w k)
  811. ((lambda (mw)
  812. ((lambda (x)
  813. (check-macro-output x)
  814. (k x r mw))
  815. (p (wrap e (join-wraps mw w)))))
  816. (new-mark-wrap)))))
  817. (chi-pair (lambda (e r w k)
  818. ((lambda (first rest)
  819. (if (id? first)
  820. ((lambda (n)
  821. ((lambda (b)
  822. ((lambda (g000175)
  823. (if (memv
  824. g000175
  825. '(core))
  826. ((binding-value b)
  827. e
  828. r
  829. w)
  830. (if (memv
  831. g000175
  832. '(macro))
  833. (chi-macro
  834. (binding-value
  835. b)
  836. e
  837. r
  838. w
  839. k)
  840. (if (memv
  841. g000175
  842. '(special))
  843. ((binding-value
  844. b)
  845. e
  846. r
  847. w
  848. k)
  849. (begin g000175
  850. (syncase:build-application
  851. (chi-ref
  852. first
  853. n
  854. b
  855. w)
  856. (chi-args
  857. rest
  858. r
  859. w
  860. e
  861. w)))))))
  862. (binding-type b)))
  863. (lookup n first r)))
  864. (id-var-name first w))
  865. (syncase:build-application
  866. (chi first r w)
  867. (chi-args rest r w e w))))
  868. (car e)
  869. (cdr e))))
  870. (chi (lambda (e r w)
  871. (if (symbol? e)
  872. ((lambda (n)
  873. (chi-ref e n (lookup n e r) w))
  874. (id-var-name e w))
  875. (if (pair? e)
  876. (chi-pair e r w chi)
  877. (if (syntax-object? e)
  878. (chi (syntax-object-expression e)
  879. r
  880. (join-wraps
  881. w
  882. (syntax-object-wrap e)))
  883. (if ((lambda (g000176)
  884. (if g000176
  885. g000176
  886. ((lambda (g000177)
  887. (if g000177
  888. g000177
  889. ((lambda (g000178)
  890. (if g000178
  891. g000178
  892. (char?
  893. e)))
  894. (string? e))))
  895. (number? e))))
  896. (boolean? e))
  897. (syncase:build-data e)
  898. (syntax-error (wrap e w))))))))
  899. (chi-top (lambda (e r w)
  900. (if (pair? e)
  901. (chi-pair e r w chi-top)
  902. (if (syntax-object? e)
  903. (chi-top
  904. (syntax-object-expression e)
  905. r
  906. (join-wraps
  907. w
  908. (syntax-object-wrap e)))
  909. (chi e r w)))))
  910. (wrap (lambda (x w)
  911. (if (null? w)
  912. x
  913. (if (syntax-object? x)
  914. (make-syntax-object
  915. (syntax-object-expression x)
  916. (join-wraps
  917. w
  918. (syntax-object-wrap x)))
  919. (if (null? x)
  920. x
  921. (make-syntax-object x w))))))
  922. (unwrap (lambda (x)
  923. (if (syntax-object? x)
  924. ((lambda (e w)
  925. (if (pair? e)
  926. (cons (wrap (car e) w)
  927. (wrap (cdr e) w))
  928. (if (vector? e)
  929. (list->vector
  930. (map (lambda (x)
  931. (wrap x w))
  932. (vector->list e)))
  933. e)))
  934. (syntax-object-expression x)
  935. (syntax-object-wrap x))
  936. x)))
  937. (bound-id-member? (lambda (x list)
  938. (if (not (null? list))
  939. ((lambda (g000179)
  940. (if g000179
  941. g000179
  942. (bound-id-member?
  943. x
  944. (cdr list))))
  945. (bound-id=? x (car list)))
  946. #f)))
  947. (valid-bound-ids? (lambda (ids)
  948. (if ((letrec ((all-ids? (lambda (ids)
  949. ((lambda (g000181)
  950. (if g000181
  951. g000181
  952. (if (id? (car ids))
  953. (all-ids?
  954. (cdr ids))
  955. #f)))
  956. (null?
  957. ids)))))
  958. all-ids?)
  959. ids)
  960. ((letrec ((unique? (lambda (ids)
  961. ((lambda (g000180)
  962. (if g000180
  963. g000180
  964. (if (not (bound-id-member?
  965. (car ids)
  966. (cdr ids)))
  967. (unique?
  968. (cdr ids))
  969. #f)))
  970. (null?
  971. ids)))))
  972. unique?)
  973. ids)
  974. #f)))
  975. (bound-id=? (lambda (i j)
  976. (if (eq? (id-sym-name i)
  977. (id-sym-name j))
  978. ((lambda (i j)
  979. (if (eq? (car i) (car j))
  980. (same-marks?
  981. (cdr i)
  982. (cdr j))
  983. #f))
  984. (id-var-name&marks i empty-wrap)
  985. (id-var-name&marks j empty-wrap))
  986. #f)))
  987. (free-id=? (lambda (i j)
  988. (if (eq? (id-sym-name i) (id-sym-name j))
  989. (eq? (id-var-name i empty-wrap)
  990. (id-var-name j empty-wrap))
  991. #f)))
  992. (id-var-name&marks (lambda (id w)
  993. (if (null? w)
  994. (if (symbol? id)
  995. (list id)
  996. (id-var-name&marks
  997. (syntax-object-expression
  998. id)
  999. (syntax-object-wrap
  1000. id)))
  1001. ((lambda (n&m first)
  1002. (if (pair? first)
  1003. ((lambda (n)
  1004. ((letrec ((search (lambda (rib)
  1005. (if (null?
  1006. rib)
  1007. n&m
  1008. (if (if (eq? (caar rib)
  1009. n)
  1010. (same-marks?
  1011. (cdr n&m)
  1012. (cddar
  1013. rib))
  1014. #f)
  1015. (cdar rib)
  1016. (search
  1017. (cdr rib)))))))
  1018. search)
  1019. first))
  1020. (car n&m))
  1021. (cons (car n&m)
  1022. (if ((lambda (g000182)
  1023. (if g000182
  1024. g000182
  1025. (not (eqv? first
  1026. (cadr n&m)))))
  1027. (null?
  1028. (cdr n&m)))
  1029. (cons first
  1030. (cdr n&m))
  1031. (cddr n&m)))))
  1032. (id-var-name&marks
  1033. id
  1034. (cdr w))
  1035. (car w)))))
  1036. (id-var-name (lambda (id w)
  1037. (if (null? w)
  1038. (if (symbol? id)
  1039. id
  1040. (id-var-name
  1041. (syntax-object-expression
  1042. id)
  1043. (syntax-object-wrap id)))
  1044. (if (pair? (car w))
  1045. (car (id-var-name&marks id w))
  1046. (id-var-name id (cdr w))))))
  1047. (same-marks? (lambda (x y)
  1048. (if (null? x)
  1049. (null? y)
  1050. (if (not (null? y))
  1051. (if (eqv? (car x) (car y))
  1052. (same-marks?
  1053. (cdr x)
  1054. (cdr y))
  1055. #f)
  1056. #f))))
  1057. (join-wraps2 (lambda (w1 w2)
  1058. ((lambda (x w1)
  1059. (if (null? w1)
  1060. (if (if (not (pair? x))
  1061. (eqv? x (car w2))
  1062. #f)
  1063. (cdr w2)
  1064. (cons x w2))
  1065. (cons x (join-wraps2 w1 w2))))
  1066. (car w1)
  1067. (cdr w1))))
  1068. (join-wraps1 (lambda (w1 w2)
  1069. (if (null? w1)
  1070. w2
  1071. (cons (car w1)
  1072. (join-wraps1 (cdr w1) w2)))))
  1073. (join-wraps (lambda (w1 w2)
  1074. (if (null? w2)
  1075. w1
  1076. (if (null? w1)
  1077. w2
  1078. (if (pair? (car w2))
  1079. (join-wraps1 w1 w2)
  1080. (join-wraps2 w1 w2))))))
  1081. (make-wrap-rib (lambda (ids new-names w)
  1082. (if (null? ids)
  1083. '()
  1084. (cons ((lambda (n&m)
  1085. (cons (car n&m)
  1086. (cons (car new-names)
  1087. (cdr n&m))))
  1088. (id-var-name&marks
  1089. (car ids)
  1090. w))
  1091. (make-wrap-rib
  1092. (cdr ids)
  1093. (cdr new-names)
  1094. w)))))
  1095. (make-binding-wrap (lambda (ids new-names w)
  1096. (if (null? ids)
  1097. w
  1098. (cons (make-wrap-rib
  1099. ids
  1100. new-names
  1101. w)
  1102. w))))
  1103. (new-mark-wrap (lambda ()
  1104. (set! current-mark
  1105. (+ current-mark 1))
  1106. (list current-mark)))
  1107. (current-mark 0)
  1108. (top-wrap '(top))
  1109. (empty-wrap '())
  1110. (id-sym-name (lambda (x)
  1111. (if (symbol? x)
  1112. x
  1113. (syntax-object-expression x))))
  1114. (id? (lambda (x)
  1115. ((lambda (g000183)
  1116. (if g000183
  1117. g000183
  1118. (if (syntax-object? x)
  1119. (symbol?
  1120. (syntax-object-expression x))
  1121. #f)))
  1122. (symbol? x))))
  1123. (global-extend (lambda (type sym val)
  1124. (extend-global-env
  1125. sym
  1126. (cons type val))))
  1127. (lookup (lambda (name id r)
  1128. (if (eq? name (id-sym-name id))
  1129. (global-lookup name)
  1130. ((letrec ((search (lambda (r name)
  1131. (if (null? r)
  1132. '(displaced-lexical)
  1133. (if (pair?
  1134. (car r))
  1135. (if (eq? (caar r)
  1136. name)
  1137. (cdar r)
  1138. (search
  1139. (cdr r)
  1140. name))
  1141. (if (eq? (car r)
  1142. name)
  1143. '(lexical)
  1144. (search
  1145. (cdr r)
  1146. name)))))))
  1147. search)
  1148. r
  1149. name))))
  1150. (extend-syntax-env (lambda (vars vals r)
  1151. (if (null? vars)
  1152. r
  1153. (cons (cons (car vars)
  1154. (cons 'syntax
  1155. (car vals)))
  1156. (extend-syntax-env
  1157. (cdr vars)
  1158. (cdr vals)
  1159. r)))))
  1160. (extend-var-env append)
  1161. (extend-macro-env (lambda (vars vals r)
  1162. (if (null? vars)
  1163. r
  1164. (cons (cons (car vars)
  1165. (cons 'macro
  1166. (car vals)))
  1167. (extend-macro-env
  1168. (cdr vars)
  1169. (cdr vals)
  1170. r)))))
  1171. (null-env '())
  1172. (global-lookup (lambda (sym)
  1173. ((lambda (g000184)
  1174. (if g000184
  1175. g000184
  1176. '(global-unbound)))
  1177. (syncase:get-global-definition-hook sym))))
  1178. (extend-global-env (lambda (sym binding)
  1179. (syncase:put-global-definition-hook
  1180. sym
  1181. binding)))
  1182. (binding-value cdr)
  1183. (binding-type car)
  1184. (arg-check (lambda (pred? x who)
  1185. (if (not (pred? x))
  1186. (syncase:error-hook who "invalid argument" x)
  1187. (syncase:void))))
  1188. (id-error (lambda (x)
  1189. (syntax-error
  1190. x
  1191. "invalid context for identifier")))
  1192. (scope-error (lambda (id)
  1193. (syntax-error
  1194. id
  1195. "invalid context for bound identifier")))
  1196. (syntax-object-wrap (lambda (x) (vector-ref x 2)))
  1197. (syntax-object-expression (lambda (x) (vector-ref x 1)))
  1198. (make-syntax-object (lambda (expression wrap)
  1199. (vector
  1200. 'syntax-object
  1201. expression
  1202. wrap)))
  1203. (syntax-object? (lambda (x)
  1204. (if (vector? x)
  1205. (if (= (vector-length x) 3)
  1206. (eq? (vector-ref x 0)
  1207. 'syntax-object)
  1208. #f)
  1209. #f))))
  1210. (global-extend 'core 'letrec-syntax chi-local-syntax)
  1211. (global-extend 'core 'let-syntax chi-local-syntax)
  1212. (global-extend
  1213. 'core
  1214. 'quote
  1215. (lambda (e r w)
  1216. ((lambda (g000136)
  1217. ((lambda (g000135)
  1218. (if (not (eq? g000135 'no))
  1219. ((lambda (__ _e) (syncase:build-data (strip _e)))
  1220. (car g000135)
  1221. (cadr g000135))
  1222. ((lambda (g000138)
  1223. ((lambda (g000137)
  1224. (if (not (eq? g000137 'no))
  1225. ((lambda (__)
  1226. (syntax-error (wrap e w)))
  1227. (car g000137))
  1228. (syntax-error g000138)))
  1229. (syntax-dispatch
  1230. g000138
  1231. '(any)
  1232. (vector))))
  1233. g000136)))
  1234. (syntax-dispatch
  1235. g000136
  1236. '(pair (any) pair (any) atom)
  1237. (vector))))
  1238. e)))
  1239. (global-extend
  1240. 'core
  1241. 'syntax
  1242. (lambda (e r w)
  1243. ((lambda (g000132)
  1244. ((lambda (g000131)
  1245. (if (not (eq? g000131 'no))
  1246. ((lambda (__ _x) (chi-syntax e _x r w))
  1247. (car g000131)
  1248. (cadr g000131))
  1249. ((lambda (g000134)
  1250. ((lambda (g000133)
  1251. (if (not (eq? g000133 'no))
  1252. ((lambda (__)
  1253. (syntax-error (wrap e w)))
  1254. (car g000133))
  1255. (syntax-error g000134)))
  1256. (syntax-dispatch
  1257. g000134
  1258. '(any)
  1259. (vector))))
  1260. g000132)))
  1261. (syntax-dispatch
  1262. g000132
  1263. '(pair (any) pair (any) atom)
  1264. (vector))))
  1265. e)))
  1266. (global-extend
  1267. 'core
  1268. 'syntax-lambda
  1269. (lambda (e r w)
  1270. ((lambda (g000127)
  1271. ((lambda (g000128)
  1272. ((lambda (g000126)
  1273. (if (not (eq? g000126 'no))
  1274. ((lambda (__ _id _level _exp)
  1275. (if (if (valid-bound-ids? _id)
  1276. (map (lambda (x)
  1277. (if (integer? x)
  1278. (if (exact? x)
  1279. (not (negative?
  1280. x))
  1281. #f)
  1282. #f))
  1283. (map unwrap _level))
  1284. #f)
  1285. ((lambda (new-vars)
  1286. (syncase:build-lambda
  1287. new-vars
  1288. (chi _exp
  1289. (extend-syntax-env
  1290. new-vars
  1291. (map unwrap
  1292. _level)
  1293. r)
  1294. (make-binding-wrap
  1295. _id
  1296. new-vars
  1297. w))))
  1298. (map gen-var _id))
  1299. (g000128)))
  1300. (car g000126)
  1301. (cadr g000126)
  1302. (caddr g000126)
  1303. (cadddr g000126))
  1304. (g000128)))
  1305. (syntax-dispatch
  1306. g000127
  1307. '(pair (any)
  1308. pair
  1309. (each pair (any) pair (any) atom)
  1310. pair
  1311. (any)
  1312. atom)
  1313. (vector))))
  1314. (lambda ()
  1315. ((lambda (g000130)
  1316. ((lambda (g000129)
  1317. (if (not (eq? g000129 'no))
  1318. ((lambda (__)
  1319. (syntax-error (wrap e w)))
  1320. (car g000129))
  1321. (syntax-error g000130)))
  1322. (syntax-dispatch
  1323. g000130
  1324. '(any)
  1325. (vector))))
  1326. g000127))))
  1327. e)))
  1328. (global-extend
  1329. 'core
  1330. 'lambda
  1331. (lambda (e r w)
  1332. ((lambda (g000121)
  1333. ((lambda (g000120)
  1334. (if (not (eq? g000120 'no))
  1335. ((lambda (__ _id _e1 _e2)
  1336. (if (not (valid-bound-ids? _id))
  1337. (syntax-error
  1338. (wrap e w)
  1339. "invalid parameter list")
  1340. ((lambda (new-vars)
  1341. (syncase:build-lambda
  1342. new-vars
  1343. (chi-body
  1344. (cons _e1 _e2)
  1345. e
  1346. (extend-var-env
  1347. new-vars
  1348. r)
  1349. (make-binding-wrap
  1350. _id
  1351. new-vars
  1352. w))))
  1353. (map gen-var _id))))
  1354. (car g000120)
  1355. (cadr g000120)
  1356. (caddr g000120)
  1357. (cadddr g000120))
  1358. ((lambda (g000123)
  1359. ((lambda (g000122)
  1360. (if (not (eq? g000122 'no))
  1361. ((lambda (__ _ids _e1 _e2)
  1362. ((lambda (old-ids)
  1363. (if (not (valid-bound-ids?
  1364. (lambda-var-list
  1365. _ids)))
  1366. (syntax-error
  1367. (wrap e w)
  1368. "invalid parameter list")
  1369. ((lambda (new-vars)
  1370. (syncase:build-improper-lambda
  1371. (reverse
  1372. (cdr new-vars))
  1373. (car new-vars)
  1374. (chi-body
  1375. (cons _e1
  1376. _e2)
  1377. e
  1378. (extend-var-env
  1379. new-vars
  1380. r)
  1381. (make-binding-wrap
  1382. old-ids
  1383. new-vars
  1384. w))))
  1385. (map gen-var
  1386. old-ids))))
  1387. (lambda-var-list _ids)))
  1388. (car g000122)
  1389. (cadr g000122)
  1390. (caddr g000122)
  1391. (cadddr g000122))
  1392. ((lambda (g000125)
  1393. ((lambda (g000124)
  1394. (if (not (eq? g000124
  1395. 'no))
  1396. ((lambda (__)
  1397. (syntax-error
  1398. (wrap e w)))
  1399. (car g000124))
  1400. (syntax-error
  1401. g000125)))
  1402. (syntax-dispatch
  1403. g000125
  1404. '(any)
  1405. (vector))))
  1406. g000123)))
  1407. (syntax-dispatch
  1408. g000123
  1409. '(pair (any)
  1410. pair
  1411. (any)
  1412. pair
  1413. (any)
  1414. each
  1415. any)
  1416. (vector))))
  1417. g000121)))
  1418. (syntax-dispatch
  1419. g000121
  1420. '(pair (any)
  1421. pair
  1422. (each any)
  1423. pair
  1424. (any)
  1425. each
  1426. any)
  1427. (vector))))
  1428. e)))
  1429. (global-extend
  1430. 'core
  1431. 'letrec
  1432. (lambda (e r w)
  1433. ((lambda (g000116)
  1434. ((lambda (g000117)
  1435. ((lambda (g000115)
  1436. (if (not (eq? g000115 'no))
  1437. (apply
  1438. (lambda (__ _id _val _e1 _e2)
  1439. (if (valid-bound-ids? _id)
  1440. ((lambda (new-vars)
  1441. ((lambda (w r)
  1442. (syncase:build-letrec
  1443. new-vars
  1444. (map (lambda (x)
  1445. (chi x
  1446. r
  1447. w))
  1448. _val)
  1449. (chi-body
  1450. (cons _e1 _e2)
  1451. e
  1452. r
  1453. w)))
  1454. (make-binding-wrap
  1455. _id
  1456. new-vars
  1457. w)
  1458. (extend-var-env
  1459. new-vars
  1460. r)))
  1461. (map gen-var _id))
  1462. (g000117)))
  1463. g000115)
  1464. (g000117)))
  1465. (syntax-dispatch
  1466. g000116
  1467. '(pair (any)
  1468. pair
  1469. (each pair (any) pair (any) atom)
  1470. pair
  1471. (any)
  1472. each
  1473. any)
  1474. (vector))))
  1475. (lambda ()
  1476. ((lambda (g000119)
  1477. ((lambda (g000118)
  1478. (if (not (eq? g000118 'no))
  1479. ((lambda (__)
  1480. (syntax-error (wrap e w)))
  1481. (car g000118))
  1482. (syntax-error g000119)))
  1483. (syntax-dispatch
  1484. g000119
  1485. '(any)
  1486. (vector))))
  1487. g000116))))
  1488. e)))
  1489. (global-extend
  1490. 'core
  1491. 'if
  1492. (lambda (e r w)
  1493. ((lambda (g000110)
  1494. ((lambda (g000109)
  1495. (if (not (eq? g000109 'no))
  1496. ((lambda (__ _test _then)
  1497. (syncase:build-conditional
  1498. (chi _test r w)
  1499. (chi _then r w)
  1500. (chi (list '#(syntax-object
  1501. syncase:void
  1502. (top)))
  1503. r
  1504. empty-wrap)))
  1505. (car g000109)
  1506. (cadr g000109)
  1507. (caddr g000109))
  1508. ((lambda (g000112)
  1509. ((lambda (g000111)
  1510. (if (not (eq? g000111 'no))
  1511. ((lambda (__ _test _then _else)
  1512. (syncase:build-conditional
  1513. (chi _test r w)
  1514. (chi _then r w)
  1515. (chi _else r w)))
  1516. (car g000111)
  1517. (cadr g000111)
  1518. (caddr g000111)
  1519. (cadddr g000111))
  1520. ((lambda (g000114)
  1521. ((lambda (g000113)
  1522. (if (not (eq? g000113
  1523. 'no))
  1524. ((lambda (__)
  1525. (syntax-error
  1526. (wrap e w)))
  1527. (car g000113))
  1528. (syntax-error
  1529. g000114)))
  1530. (syntax-dispatch
  1531. g000114
  1532. '(any)
  1533. (vector))))
  1534. g000112)))
  1535. (syntax-dispatch
  1536. g000112
  1537. '(pair (any)
  1538. pair
  1539. (any)
  1540. pair
  1541. (any)
  1542. pair
  1543. (any)
  1544. atom)
  1545. (vector))))
  1546. g000110)))
  1547. (syntax-dispatch
  1548. g000110
  1549. '(pair (any) pair (any) pair (any) atom)
  1550. (vector))))
  1551. e)))
  1552. (global-extend
  1553. 'core
  1554. 'set!
  1555. (lambda (e r w)
  1556. ((lambda (g000104)
  1557. ((lambda (g000105)
  1558. ((lambda (g000103)
  1559. (if (not (eq? g000103 'no))
  1560. ((lambda (__ _id _val)
  1561. (if (id? _id)
  1562. ((lambda (val n)
  1563. ((lambda (g000108)
  1564. (if (memv
  1565. g000108
  1566. '(lexical))
  1567. (syncase:build-lexical-assignment
  1568. n
  1569. val)
  1570. (if (memv
  1571. g000108
  1572. '(global
  1573. global-unbound))
  1574. (syncase:build-global-assignment
  1575. n
  1576. val)
  1577. (begin g000108
  1578. (id-error
  1579. (wrap _id
  1580. w))))))
  1581. (binding-type
  1582. (lookup n _id r))))
  1583. (chi _val r w)
  1584. (id-var-name _id w))
  1585. (g000105)))
  1586. (car g000103)
  1587. (cadr g000103)
  1588. (caddr g000103))
  1589. (g000105)))
  1590. (syntax-dispatch
  1591. g000104
  1592. '(pair (any) pair (any) pair (any) atom)
  1593. (vector))))
  1594. (lambda ()
  1595. ((lambda (g000107)
  1596. ((lambda (g000106)
  1597. (if (not (eq? g000106 'no))
  1598. ((lambda (__)
  1599. (syntax-error (wrap e w)))
  1600. (car g000106))
  1601. (syntax-error g000107)))
  1602. (syntax-dispatch
  1603. g000107
  1604. '(any)
  1605. (vector))))
  1606. g000104))))
  1607. e)))
  1608. (global-extend
  1609. 'special
  1610. 'begin
  1611. (lambda (e r w k)
  1612. ((lambda (body)
  1613. (if (null? body)
  1614. (if (eqv? k chi-top)
  1615. (chi (list '#(syntax-object syncase:void (top)))
  1616. r
  1617. empty-wrap)
  1618. (syntax-error
  1619. (wrap e w)
  1620. "no expressions in body of"))
  1621. (syncase:build-sequence
  1622. ((letrec ((dobody (lambda (body)
  1623. (if (null? body)
  1624. '()
  1625. ((lambda (first)
  1626. (cons first
  1627. (dobody
  1628. (cdr body))))
  1629. (k (car body)
  1630. r
  1631. empty-wrap))))))
  1632. dobody)
  1633. body))))
  1634. (chi-sequence e w))))
  1635. (global-extend
  1636. 'special
  1637. 'define
  1638. (lambda (e r w k)
  1639. (if (eqv? k chi-top)
  1640. ((lambda (n&v)
  1641. ((lambda (n)
  1642. (global-extend 'global n '())
  1643. (syncase:build-global-definition
  1644. n
  1645. (chi (cadr n&v) r empty-wrap)))
  1646. (id-var-name (car n&v) empty-wrap)))
  1647. (chi-definition e w))
  1648. (syntax-error
  1649. (wrap e w)
  1650. "invalid context for definition"))))
  1651. (global-extend
  1652. 'special
  1653. 'define-syntax
  1654. (lambda (e r w k)
  1655. (if (eqv? k chi-top)
  1656. ((lambda (n&v)
  1657. (global-extend
  1658. 'macro
  1659. (id-var-name (car n&v) empty-wrap)
  1660. (chi-macro-def (cadr n&v) r empty-wrap))
  1661. (chi (list '#(syntax-object syncase:void (top)))
  1662. r
  1663. empty-wrap))
  1664. (chi-syntax-definition e w))
  1665. (syntax-error
  1666. (wrap e w)
  1667. "invalid context for definition"))))
  1668. (set! expand-syntax
  1669. (lambda (x) (chi-top x null-env top-wrap)))
  1670. (set! implicit-identifier
  1671. (lambda (id sym)
  1672. (arg-check id? id 'implicit-identifier)
  1673. (arg-check symbol? sym 'implicit-identifier)
  1674. (if (syntax-object? id)
  1675. (wrap sym (syntax-object-wrap id))
  1676. sym)))
  1677. (set! syntax-object->datum (lambda (x) (strip x)))
  1678. (set! generate-temporaries
  1679. (lambda (ls)
  1680. (arg-check list? ls 'generate-temporaries)
  1681. (map (lambda (x) (wrap (syncase:new-symbol-hook "g") top-wrap)) ls)))
  1682. (set! free-identifier=?
  1683. (lambda (x y)
  1684. (arg-check id? x 'free-identifier=?)
  1685. (arg-check id? y 'free-identifier=?)
  1686. (free-id=? x y)))
  1687. (set! bound-identifier=?
  1688. (lambda (x y)
  1689. (arg-check id? x 'bound-identifier=?)
  1690. (arg-check id? y 'bound-identifier=?)
  1691. (bound-id=? x y)))
  1692. (set! identifier? (lambda (x) (id? x)))
  1693. (set! syntax-error
  1694. (lambda (object . messages)
  1695. (for-each
  1696. (lambda (x) (arg-check string? x 'syntax-error))
  1697. messages)
  1698. ((lambda (message)
  1699. (syncase:error-hook 'expand-syntax message (strip object)))
  1700. (if (null? messages)
  1701. "invalid syntax"
  1702. (apply string-append messages)))))
  1703. (set! syncase:install-global-transformer
  1704. (lambda (sym p) (global-extend 'macro sym p)))
  1705. ((lambda ()
  1706. (letrec ((match (lambda (e p k w r)
  1707. (if (eq? r 'no)
  1708. r
  1709. ((lambda (g000100)
  1710. (if (memv g000100 '(any))
  1711. (cons (wrap e w) r)
  1712. (if (memv
  1713. g000100
  1714. '(free-id))
  1715. (if (if (identifier?
  1716. e)
  1717. (free-id=?
  1718. (wrap e w)
  1719. (vector-ref
  1720. k
  1721. (cdr p)))
  1722. #f)
  1723. r
  1724. 'no)
  1725. (begin g000100
  1726. (if (syntax-object?
  1727. e)
  1728. (match*
  1729. (syntax-object-expression
  1730. e)
  1731. p
  1732. k
  1733. (join-wraps
  1734. w
  1735. (syntax-object-wrap
  1736. e))
  1737. r)
  1738. (match*
  1739. e
  1740. p
  1741. k
  1742. w
  1743. r))))))
  1744. (car p)))))
  1745. (match* (lambda (e p k w r)
  1746. ((lambda (g000101)
  1747. (if (memv g000101 '(pair))
  1748. (if (pair? e)
  1749. (match
  1750. (car e)
  1751. (cadr p)
  1752. k
  1753. w
  1754. (match
  1755. (cdr e)
  1756. (cddr p)
  1757. k
  1758. w
  1759. r))
  1760. 'no)
  1761. (if (memv g000101 '(each))
  1762. (if (eq? (cadr p) 'any)
  1763. ((lambda (l)
  1764. (if (eq? l 'no)
  1765. l
  1766. (cons l r)))
  1767. (match-each-any
  1768. e
  1769. w))
  1770. (if (null? e)
  1771. (match-empty
  1772. (cdr p)
  1773. r)
  1774. ((lambda (l)
  1775. (if (eq? l
  1776. 'no)
  1777. l
  1778. ((letrec ((collect (lambda (l)
  1779. (if (null?
  1780. (car l))
  1781. r
  1782. (cons (map car
  1783. l)
  1784. (collect
  1785. (map cdr
  1786. l)))))))
  1787. collect)
  1788. l)))
  1789. (match-each
  1790. e
  1791. (cdr p)
  1792. k
  1793. w))))
  1794. (if (memv
  1795. g000101
  1796. '(atom))
  1797. (if (equal?
  1798. (cdr p)
  1799. e)
  1800. r
  1801. 'no)
  1802. (if (memv
  1803. g000101
  1804. '(vector))
  1805. (if (vector? e)
  1806. (match
  1807. (vector->list
  1808. e)
  1809. (cdr p)
  1810. k
  1811. w
  1812. r)
  1813. 'no)
  1814. (begin g000101
  1815. (syncase:void)))))))
  1816. (car p))))
  1817. (match-empty (lambda (p r)
  1818. ((lambda (g000102)
  1819. (if (memv g000102 '(any))
  1820. (cons '() r)
  1821. (if (memv
  1822. g000102
  1823. '(each))
  1824. (match-empty
  1825. (cdr p)
  1826. r)
  1827. (if (memv
  1828. g000102
  1829. '(pair))
  1830. (match-empty
  1831. (cadr p)
  1832. (match-empty
  1833. (cddr p)
  1834. r))
  1835. (if (memv
  1836. g000102
  1837. '(free-id
  1838. atom))
  1839. r
  1840. (if (memv
  1841. g000102
  1842. '(vector))
  1843. (match-empty
  1844. (cdr p)
  1845. r)
  1846. (begin g000102
  1847. (syncase:void))))))))
  1848. (car p))))
  1849. (match-each-any (lambda (e w)
  1850. (if (pair? e)
  1851. ((lambda (l)
  1852. (if (eq? l 'no)
  1853. l
  1854. (cons (wrap (car e)
  1855. w)
  1856. l)))
  1857. (match-each-any
  1858. (cdr e)
  1859. w))
  1860. (if (null? e)
  1861. '()
  1862. (if (syntax-object?
  1863. e)
  1864. (match-each-any
  1865. (syntax-object-expression
  1866. e)
  1867. (join-wraps
  1868. w
  1869. (syntax-object-wrap
  1870. e)))
  1871. 'no)))))
  1872. (match-each (lambda (e p k w)
  1873. (if (pair? e)
  1874. ((lambda (first)
  1875. (if (eq? first 'no)
  1876. first
  1877. ((lambda (rest)
  1878. (if (eq? rest
  1879. 'no)
  1880. rest
  1881. (cons first
  1882. rest)))
  1883. (match-each
  1884. (cdr e)
  1885. p
  1886. k
  1887. w))))
  1888. (match (car e) p k w '()))
  1889. (if (null? e)
  1890. '()
  1891. (if (syntax-object? e)
  1892. (match-each
  1893. (syntax-object-expression
  1894. e)
  1895. p
  1896. k
  1897. (join-wraps
  1898. w
  1899. (syntax-object-wrap
  1900. e)))
  1901. 'no))))))
  1902. (set! syntax-dispatch
  1903. (lambda (expression pattern keys)
  1904. (match
  1905. expression
  1906. pattern
  1907. keys
  1908. empty-wrap
  1909. '())))))))))
  1910. (syncase:install-global-transformer
  1911. 'let
  1912. (lambda (x)
  1913. ((lambda (g00095)
  1914. ((lambda (g00096)
  1915. ((lambda (g00094)
  1916. (if (not (eq? g00094 'no))
  1917. (apply
  1918. (lambda (__ _x _v _e1 _e2)
  1919. (if (syncase:andmap identifier? _x)
  1920. (cons (cons '#(syntax-object
  1921. lambda
  1922. (top))
  1923. (cons _x
  1924. (cons _e1 _e2)))
  1925. _v)
  1926. (g00096)))
  1927. g00094)
  1928. (g00096)))
  1929. (syntax-dispatch
  1930. g00095
  1931. '(pair (any)
  1932. pair
  1933. (each pair (any) pair (any) atom)
  1934. pair
  1935. (any)
  1936. each
  1937. any)
  1938. (vector))))
  1939. (lambda ()
  1940. ((lambda (g00098)
  1941. ((lambda (g00099)
  1942. ((lambda (g00097)
  1943. (if (not (eq? g00097 'no))
  1944. (apply
  1945. (lambda (__ _f _x _v _e1 _e2)
  1946. (if (syncase:andmap
  1947. identifier?
  1948. (cons _f _x))
  1949. (cons (list '#(syntax-object
  1950. letrec
  1951. (top))
  1952. (list (list _f
  1953. (cons '#(syntax-object
  1954. lambda
  1955. (top))
  1956. (cons _x
  1957. (cons _e1
  1958. _e2)))))
  1959. _f)
  1960. _v)
  1961. (g00099)))
  1962. g00097)
  1963. (g00099)))
  1964. (syntax-dispatch
  1965. g00098
  1966. '(pair (any)
  1967. pair
  1968. (any)
  1969. pair
  1970. (each pair (any) pair (any) atom)
  1971. pair
  1972. (any)
  1973. each
  1974. any)
  1975. (vector))))
  1976. (lambda () (syntax-error g00098))))
  1977. g00095))))
  1978. x)))
  1979. (syncase:install-global-transformer
  1980. 'syntax-case
  1981. ((lambda ()
  1982. (letrec ((syncase:build-dispatch-call (lambda (args body val)
  1983. ((lambda (g00046)
  1984. ((lambda (g00045)
  1985. (if (not (eq? g00045
  1986. 'no))
  1987. body
  1988. ((lambda (g00048)
  1989. ((lambda (g00047)
  1990. (if (not (eq? g00047
  1991. 'no))
  1992. ((lambda (_arg1)
  1993. ((lambda (g00066)
  1994. ((lambda (g00065)
  1995. (if (not (eq? g00065
  1996. 'no))
  1997. ((lambda (_body
  1998. _val)
  1999. (list (list '#(syntax-object
  2000. syntax-lambda
  2001. (top))
  2002. (list _arg1)
  2003. _body)
  2004. (list '#(syntax-object
  2005. car
  2006. (top))
  2007. _val)))
  2008. (car g00065)
  2009. (cadr g00065))
  2010. (syntax-error
  2011. g00066)))
  2012. (syntax-dispatch
  2013. g00066
  2014. '(pair (any)
  2015. pair
  2016. (any)
  2017. atom)
  2018. (vector))))
  2019. (list body
  2020. val)))
  2021. (car g00047))
  2022. ((lambda (g00050)
  2023. ((lambda (g00049)
  2024. (if (not (eq? g00049
  2025. 'no))
  2026. ((lambda (_arg1
  2027. _arg2)
  2028. ((lambda (g00064)
  2029. ((lambda (g00063)
  2030. (if (not (eq? g00063
  2031. 'no))
  2032. ((lambda (_body
  2033. _val)
  2034. (list (list '#(syntax-object
  2035. syntax-lambda
  2036. (top))
  2037. (list _arg1
  2038. _arg2)
  2039. _body)
  2040. (list '#(syntax-object
  2041. car
  2042. (top))
  2043. _val)
  2044. (list '#(syntax-object
  2045. cadr
  2046. (top))
  2047. _val)))
  2048. (car g00063)
  2049. (cadr g00063))
  2050. (syntax-error
  2051. g00064)))
  2052. (syntax-dispatch
  2053. g00064
  2054. '(pair (any)
  2055. pair
  2056. (any)
  2057. atom)
  2058. (vector))))
  2059. (list body
  2060. val)))
  2061. (car g00049)
  2062. (cadr g00049))
  2063. ((lambda (g00052)
  2064. ((lambda (g00051)
  2065. (if (not (eq? g00051
  2066. 'no))
  2067. ((lambda (_arg1
  2068. _arg2
  2069. _arg3)
  2070. ((lambda (g00062)
  2071. ((lambda (g00061)
  2072. (if (not (eq? g00061
  2073. 'no))
  2074. ((lambda (_body
  2075. _val)
  2076. (list (list '#(syntax-object
  2077. syntax-lambda
  2078. (top))
  2079. (list _arg1
  2080. _arg2
  2081. _arg3)
  2082. _body)
  2083. (list '#(syntax-object
  2084. car
  2085. (top))
  2086. _val)
  2087. (list '#(syntax-object
  2088. cadr
  2089. (top))
  2090. _val)
  2091. (list '#(syntax-object
  2092. caddr
  2093. (top))
  2094. _val)))
  2095. (car g00061)
  2096. (cadr g00061))
  2097. (syntax-error
  2098. g00062)))
  2099. (syntax-dispatch
  2100. g00062
  2101. '(pair (any)
  2102. pair
  2103. (any)
  2104. atom)
  2105. (vector))))
  2106. (list body
  2107. val)))
  2108. (car g00051)
  2109. (cadr g00051)
  2110. (caddr
  2111. g00051))
  2112. ((lambda (g00054)
  2113. ((lambda (g00053)
  2114. (if (not (eq? g00053
  2115. 'no))
  2116. ((lambda (_arg1
  2117. _arg2
  2118. _arg3
  2119. _arg4)
  2120. ((lambda (g00060)
  2121. ((lambda (g00059)
  2122. (if (not (eq? g00059
  2123. 'no))
  2124. ((lambda (_body
  2125. _val)
  2126. (list (list '#(syntax-object
  2127. syntax-lambda
  2128. (top))
  2129. (list _arg1
  2130. _arg2
  2131. _arg3
  2132. _arg4)
  2133. _body)
  2134. (list '#(syntax-object
  2135. car
  2136. (top))
  2137. _val)
  2138. (list '#(syntax-object
  2139. cadr
  2140. (top))
  2141. _val)
  2142. (list '#(syntax-object
  2143. caddr
  2144. (top))
  2145. _val)
  2146. (list '#(syntax-object
  2147. cadddr
  2148. (top))
  2149. _val)))
  2150. (car g00059)
  2151. (cadr g00059))
  2152. (syntax-error
  2153. g00060)))
  2154. (syntax-dispatch
  2155. g00060
  2156. '(pair (any)
  2157. pair
  2158. (any)
  2159. atom)
  2160. (vector))))
  2161. (list body
  2162. val)))
  2163. (car g00053)
  2164. (cadr g00053)
  2165. (caddr
  2166. g00053)
  2167. (cadddr
  2168. g00053))
  2169. ((lambda (g00056)
  2170. ((lambda (g00055)
  2171. (if (not (eq? g00055
  2172. 'no))
  2173. ((lambda (_arg)
  2174. ((lambda (g00058)
  2175. ((lambda (g00057)
  2176. (if (not (eq? g00057
  2177. 'no))
  2178. ((lambda (_body
  2179. _val)
  2180. (list '#(syntax-object
  2181. apply
  2182. (top))
  2183. (list '#(syntax-object
  2184. syntax-lambda
  2185. (top))
  2186. _arg
  2187. _body)
  2188. _val))
  2189. (car g00057)
  2190. (cadr g00057))
  2191. (syntax-error
  2192. g00058)))
  2193. (syntax-dispatch
  2194. g00058
  2195. '(pair (any)
  2196. pair
  2197. (any)
  2198. atom)
  2199. (vector))))
  2200. (list body
  2201. val)))
  2202. (car g00055))
  2203. (syntax-error
  2204. g00056)))
  2205. (syntax-dispatch
  2206. g00056
  2207. '(each any)
  2208. (vector))))
  2209. g00054)))
  2210. (syntax-dispatch
  2211. g00054
  2212. '(pair (any)
  2213. pair
  2214. (any)
  2215. pair
  2216. (any)
  2217. pair
  2218. (any)
  2219. atom)
  2220. (vector))))
  2221. g00052)))
  2222. (syntax-dispatch
  2223. g00052
  2224. '(pair (any)
  2225. pair
  2226. (any)
  2227. pair
  2228. (any)
  2229. atom)
  2230. (vector))))
  2231. g00050)))
  2232. (syntax-dispatch
  2233. g00050
  2234. '(pair (any)
  2235. pair
  2236. (any)
  2237. atom)
  2238. (vector))))
  2239. g00048)))
  2240. (syntax-dispatch
  2241. g00048
  2242. '(pair (any)
  2243. atom)
  2244. (vector))))
  2245. g00046)))
  2246. (syntax-dispatch
  2247. g00046
  2248. '(atom)
  2249. (vector))))
  2250. args)))
  2251. (extract-bound-syntax-ids (lambda (pattern keys)
  2252. ((letrec ((gen (lambda (p
  2253. n
  2254. ids)
  2255. (if (identifier?
  2256. p)
  2257. (if (key? p
  2258. keys)
  2259. ids
  2260. (cons (list p
  2261. n)
  2262. ids))
  2263. ((lambda (g00068)
  2264. ((lambda (g00069)
  2265. ((lambda (g00067)
  2266. (if (not (eq? g00067
  2267. 'no))
  2268. ((lambda (_x
  2269. _dots)
  2270. (if (ellipsis?
  2271. _dots)
  2272. (gen _x
  2273. (+ n
  2274. 1)
  2275. ids)
  2276. (g00069)))
  2277. (car g00067)
  2278. (cadr g00067))
  2279. (g00069)))
  2280. (syntax-dispatch
  2281. g00068
  2282. '(pair (any)
  2283. pair
  2284. (any)
  2285. atom)
  2286. (vector))))
  2287. (lambda ()
  2288. ((lambda (g00071)
  2289. ((lambda (g00070)
  2290. (if (not (eq? g00070
  2291. 'no))
  2292. ((lambda (_x
  2293. _y)
  2294. (gen _x
  2295. n
  2296. (gen _y
  2297. n
  2298. ids)))
  2299. (car g00070)
  2300. (cadr g00070))
  2301. ((lambda (g00073)
  2302. ((lambda (g00072)
  2303. (if (not (eq? g00072
  2304. 'no))
  2305. ((lambda (_x)
  2306. (gen _x
  2307. n
  2308. ids))
  2309. (car g00072))
  2310. ((lambda (g00075)
  2311. ((lambda (g00074)
  2312. (if (not (eq? g00074
  2313. 'no))
  2314. ((lambda (_x)
  2315. ids)
  2316. (car g00074))
  2317. (syntax-error
  2318. g00075)))
  2319. (syntax-dispatch
  2320. g00075
  2321. '(any)
  2322. (vector))))
  2323. g00073)))
  2324. (syntax-dispatch
  2325. g00073
  2326. '(vector
  2327. each
  2328. any)
  2329. (vector))))
  2330. g00071)))
  2331. (syntax-dispatch
  2332. g00071
  2333. '(pair (any)
  2334. any)
  2335. (vector))))
  2336. g00068))))
  2337. p)))))
  2338. gen)
  2339. pattern
  2340. 0
  2341. '())))
  2342. (valid-syntax-pattern? (lambda (pattern keys)
  2343. (letrec ((check? (lambda (p
  2344. ids)
  2345. (if (identifier?
  2346. p)
  2347. (if (eq? ids
  2348. 'no)
  2349. ids
  2350. (if (key? p
  2351. keys)
  2352. ids
  2353. (if (if (not (ellipsis?
  2354. p))
  2355. (not (memid
  2356. p
  2357. ids))
  2358. #f)
  2359. (cons p
  2360. ids)
  2361. 'no)))
  2362. ((lambda (g00077)
  2363. ((lambda (g00078)
  2364. ((lambda (g00076)
  2365. (if (not (eq? g00076
  2366. 'no))
  2367. ((lambda (_x
  2368. _dots)
  2369. (if (ellipsis?
  2370. _dots)
  2371. (check?
  2372. _x
  2373. ids)
  2374. (g00078)))
  2375. (car g00076)
  2376. (cadr g00076))
  2377. (g00078)))
  2378. (syntax-dispatch
  2379. g00077
  2380. '(pair (any)
  2381. pair
  2382. (any)
  2383. atom)
  2384. (vector))))
  2385. (lambda ()
  2386. ((lambda (g00080)
  2387. ((lambda (g00079)
  2388. (if (not (eq? g00079
  2389. 'no))
  2390. ((lambda (_x
  2391. _y)
  2392. (check?
  2393. _x
  2394. (check?
  2395. _y
  2396. ids)))
  2397. (car g00079)
  2398. (cadr g00079))
  2399. ((lambda (g00082)
  2400. ((lambda (g00081)
  2401. (if (not (eq? g00081
  2402. 'no))
  2403. ((lambda (_x)
  2404. (check?
  2405. _x
  2406. ids))
  2407. (car g00081))
  2408. ((lambda (g00084)
  2409. ((lambda (g00083)
  2410. (if (not (eq? g00083
  2411. 'no))
  2412. ((lambda (_x)
  2413. ids)
  2414. (car g00083))
  2415. (syntax-error
  2416. g00084)))
  2417. (syntax-dispatch
  2418. g00084
  2419. '(any)
  2420. (vector))))
  2421. g00082)))
  2422. (syntax-dispatch
  2423. g00082
  2424. '(vector
  2425. each
  2426. any)
  2427. (vector))))
  2428. g00080)))
  2429. (syntax-dispatch
  2430. g00080
  2431. '(pair (any)
  2432. any)
  2433. (vector))))
  2434. g00077))))
  2435. p)))))
  2436. (not (eq? (check?
  2437. pattern
  2438. '())
  2439. 'no)))))
  2440. (valid-keyword? (lambda (k)
  2441. (if (identifier? k)
  2442. (not (free-identifier=?
  2443. k
  2444. '...))
  2445. #f)))
  2446. (convert-syntax-dispatch-pattern (lambda (pattern
  2447. keys)
  2448. ((letrec ((gen (lambda (p)
  2449. (if (identifier?
  2450. p)
  2451. (if (key? p
  2452. keys)
  2453. (cons '#(syntax-object
  2454. free-id
  2455. (top))
  2456. (key-index
  2457. p
  2458. keys))
  2459. (list '#(syntax-object
  2460. any
  2461. (top))))
  2462. ((lambda (g00086)
  2463. ((lambda (g00087)
  2464. ((lambda (g00085)
  2465. (if (not (eq? g00085
  2466. 'no))
  2467. ((lambda (_x
  2468. _dots)
  2469. (if (ellipsis?
  2470. _dots)
  2471. (cons '#(syntax-object
  2472. each
  2473. (top))
  2474. (gen _x))
  2475. (g00087)))
  2476. (car g00085)
  2477. (cadr g00085))
  2478. (g00087)))
  2479. (syntax-dispatch
  2480. g00086
  2481. '(pair (any)
  2482. pair
  2483. (any)
  2484. atom)
  2485. (vector))))
  2486. (lambda ()
  2487. ((lambda (g00089)
  2488. ((lambda (g00088)
  2489. (if (not (eq? g00088
  2490. 'no))
  2491. ((lambda (_x
  2492. _y)
  2493. (cons '#(syntax-object
  2494. pair
  2495. (top))
  2496. (cons (gen _x)
  2497. (gen _y))))
  2498. (car g00088)
  2499. (cadr g00088))
  2500. ((lambda (g00091)
  2501. ((lambda (g00090)
  2502. (if (not (eq? g00090
  2503. 'no))
  2504. ((lambda (_x)
  2505. (cons '#(syntax-object
  2506. vector
  2507. (top))
  2508. (gen _x)))
  2509. (car g00090))
  2510. ((lambda (g00093)
  2511. ((lambda (g00092)
  2512. (if (not (eq? g00092
  2513. 'no))
  2514. ((lambda (_x)
  2515. (cons '#(syntax-object
  2516. atom
  2517. (top))
  2518. p))
  2519. (car g00092))
  2520. (syntax-error
  2521. g00093)))
  2522. (syntax-dispatch
  2523. g00093
  2524. '(any)
  2525. (vector))))
  2526. g00091)))
  2527. (syntax-dispatch
  2528. g00091
  2529. '(vector
  2530. each
  2531. any)
  2532. (vector))))
  2533. g00089)))
  2534. (syntax-dispatch
  2535. g00089
  2536. '(pair (any)
  2537. any)
  2538. (vector))))
  2539. g00086))))
  2540. p)))))
  2541. gen)
  2542. pattern)))
  2543. (key-index (lambda (p keys)
  2544. (- (length keys)
  2545. (length (memid p keys)))))
  2546. (key? (lambda (p keys)
  2547. (if (identifier? p) (memid p keys) #f)))
  2548. (memid (lambda (i ids)
  2549. (if (not (null? ids))
  2550. (if (bound-identifier=? i (car ids))
  2551. ids
  2552. (memid i (cdr ids)))
  2553. #f)))
  2554. (ellipsis? (lambda (x)
  2555. (if (identifier? x)
  2556. (free-identifier=? x '...)
  2557. #f))))
  2558. (lambda (x)
  2559. ((lambda (g00030)
  2560. ((lambda (g00031)
  2561. ((lambda (g00029)
  2562. (if (not (eq? g00029 'no))
  2563. ((lambda (__ _val _key)
  2564. (if (syncase:andmap valid-keyword? _key)
  2565. (list '#(syntax-object
  2566. syntax-error
  2567. (top))
  2568. _val)
  2569. (g00031)))
  2570. (car g00029)
  2571. (cadr g00029)
  2572. (caddr g00029))
  2573. (g00031)))
  2574. (syntax-dispatch
  2575. g00030
  2576. '(pair (any)
  2577. pair
  2578. (any)
  2579. pair
  2580. (each any)
  2581. atom)
  2582. (vector))))
  2583. (lambda ()
  2584. ((lambda (g00033)
  2585. ((lambda (g00034)
  2586. ((lambda (g00032)
  2587. (if (not (eq? g00032 'no))
  2588. (apply
  2589. (lambda (__
  2590. _val
  2591. _key
  2592. _pat
  2593. _exp)
  2594. (if (if (identifier?
  2595. _pat)
  2596. (if (syncase:andmap
  2597. valid-keyword?
  2598. _key)
  2599. (syncase:andmap
  2600. (lambda (x)
  2601. (not (free-identifier=?
  2602. _pat
  2603. x)))
  2604. (cons '...
  2605. _key))
  2606. #f)
  2607. #f)
  2608. (list (list '#(syntax-object
  2609. syntax-lambda
  2610. (top))
  2611. (list (list _pat
  2612. 0))
  2613. _exp)
  2614. _val)
  2615. (g00034)))
  2616. g00032)
  2617. (g00034)))
  2618. (syntax-dispatch
  2619. g00033
  2620. '(pair (any)
  2621. pair
  2622. (any)
  2623. pair
  2624. (each any)
  2625. pair
  2626. (pair (any) pair (any) atom)
  2627. atom)
  2628. (vector))))
  2629. (lambda ()
  2630. ((lambda (g00036)
  2631. ((lambda (g00037)
  2632. ((lambda (g00035)
  2633. (if (not (eq? g00035 'no))
  2634. (apply
  2635. (lambda (__
  2636. _val
  2637. _key
  2638. _pat
  2639. _exp
  2640. _e1
  2641. _e2
  2642. _e3)
  2643. (if (if (syncase:andmap
  2644. valid-keyword?
  2645. _key)
  2646. (valid-syntax-pattern?
  2647. _pat
  2648. _key)
  2649. #f)
  2650. ((lambda (g00044)
  2651. ((lambda (g00043)
  2652. (if (not (eq? g00043
  2653. 'no))
  2654. ((lambda (_pattern
  2655. _y
  2656. _call)
  2657. (list '#(syntax-object
  2658. let
  2659. (top))
  2660. (list (list '#(syntax-object
  2661. x
  2662. (top))
  2663. _val))
  2664. (list '#(syntax-object
  2665. let
  2666. (top))
  2667. (list (list _y
  2668. (list '#(syntax-object
  2669. syntax-dispatch
  2670. (top))
  2671. '#(syntax-object
  2672. x
  2673. (top))
  2674. (list '#(syntax-object
  2675. quote
  2676. (top))
  2677. _pattern)
  2678. (list '#(syntax-object
  2679. syntax
  2680. (top))
  2681. (list->vector
  2682. _key)))))
  2683. (list '#(syntax-object
  2684. if
  2685. (top))
  2686. (list '#(syntax-object
  2687. not
  2688. (top))
  2689. (list '#(syntax-object
  2690. eq?
  2691. (top))
  2692. _y
  2693. (list '#(syntax-object
  2694. quote
  2695. (top))
  2696. '#(syntax-object
  2697. no
  2698. (top)))))
  2699. _call
  2700. (cons '#(syntax-object
  2701. syntax-case
  2702. (top))
  2703. (cons '#(syntax-object
  2704. x
  2705. (top))
  2706. (cons _key
  2707. (map (lambda (__e1
  2708. __e2
  2709. __e3)
  2710. (cons __e1
  2711. (cons __e2
  2712. __e3)))
  2713. _e1
  2714. _e2
  2715. _e3))))))))
  2716. (car g00043)
  2717. (cadr g00043)
  2718. (caddr
  2719. g00043))
  2720. (syntax-error
  2721. g00044)))
  2722. (syntax-dispatch
  2723. g00044
  2724. '(pair (any)
  2725. pair
  2726. (any)
  2727. pair
  2728. (any)
  2729. atom)
  2730. (vector))))
  2731. (list (convert-syntax-dispatch-pattern
  2732. _pat
  2733. _key)
  2734. '#(syntax-object
  2735. y
  2736. (top))
  2737. (syncase:build-dispatch-call
  2738. (extract-bound-syntax-ids
  2739. _pat
  2740. _key)
  2741. _exp
  2742. '#(syntax-object
  2743. y
  2744. (top)))))
  2745. (g00037)))
  2746. g00035)
  2747. (g00037)))
  2748. (syntax-dispatch
  2749. g00036
  2750. '(pair (any)
  2751. pair
  2752. (any)
  2753. pair
  2754. (each any)
  2755. pair
  2756. (pair (any)
  2757. pair
  2758. (any)
  2759. atom)
  2760. each
  2761. pair
  2762. (any)
  2763. pair
  2764. (any)
  2765. each
  2766. any)
  2767. (vector))))
  2768. (lambda ()
  2769. ((lambda (g00039)
  2770. ((lambda (g00040)
  2771. ((lambda (g00038)
  2772. (if (not (eq? g00038
  2773. 'no))
  2774. (apply
  2775. (lambda (__
  2776. _val
  2777. _key
  2778. _pat
  2779. _fender
  2780. _exp
  2781. _e1
  2782. _e2
  2783. _e3)
  2784. (if (if (syncase:andmap
  2785. valid-keyword?
  2786. _key)
  2787. (valid-syntax-pattern?
  2788. _pat
  2789. _key)
  2790. #f)
  2791. ((lambda (g00042)
  2792. ((lambda (g00041)
  2793. (if (not (eq? g00041
  2794. 'no))
  2795. ((lambda (_pattern
  2796. _y
  2797. _dorest
  2798. _call)
  2799. (list '#(syntax-object
  2800. let
  2801. (top))
  2802. (list (list '#(syntax-object
  2803. x
  2804. (top))
  2805. _val))
  2806. (list '#(syntax-object
  2807. let
  2808. (top))
  2809. (list (list _dorest
  2810. (list '#(syntax-object
  2811. lambda
  2812. (top))
  2813. '()
  2814. (cons '#(syntax-object
  2815. syntax-case
  2816. (top))
  2817. (cons '#(syntax-object
  2818. x
  2819. (top))
  2820. (cons _key
  2821. (map (lambda (__e1
  2822. __e2
  2823. __e3)
  2824. (cons __e1
  2825. (cons __e2
  2826. __e3)))
  2827. _e1
  2828. _e2
  2829. _e3)))))))
  2830. (list '#(syntax-object
  2831. let
  2832. (top))
  2833. (list (list _y
  2834. (list '#(syntax-object
  2835. syntax-dispatch
  2836. (top))
  2837. '#(syntax-object
  2838. x
  2839. (top))
  2840. (list '#(syntax-object
  2841. quote
  2842. (top))
  2843. _pattern)
  2844. (list '#(syntax-object
  2845. syntax
  2846. (top))
  2847. (list->vector
  2848. _key)))))
  2849. (list '#(syntax-object
  2850. if
  2851. (top))
  2852. (list '#(syntax-object
  2853. not
  2854. (top))
  2855. (list '#(syntax-object
  2856. eq?
  2857. (top))
  2858. _y
  2859. (list '#(syntax-object
  2860. quote
  2861. (top))
  2862. '#(syntax-object
  2863. no
  2864. (top)))))
  2865. _call
  2866. (list _dorest))))))
  2867. (car g00041)
  2868. (cadr g00041)
  2869. (caddr
  2870. g00041)
  2871. (cadddr
  2872. g00041))
  2873. (syntax-error
  2874. g00042)))
  2875. (syntax-dispatch
  2876. g00042
  2877. '(pair (any)
  2878. pair
  2879. (any)
  2880. pair
  2881. (any)
  2882. pair
  2883. (any)
  2884. atom)
  2885. (vector))))
  2886. (list (convert-syntax-dispatch-pattern
  2887. _pat
  2888. _key)
  2889. '#(syntax-object
  2890. y
  2891. (top))
  2892. '#(syntax-object
  2893. dorest
  2894. (top))
  2895. (syncase:build-dispatch-call
  2896. (extract-bound-syntax-ids
  2897. _pat
  2898. _key)
  2899. (list '#(syntax-object
  2900. if
  2901. (top))
  2902. _fender
  2903. _exp
  2904. (list '#(syntax-object
  2905. dorest
  2906. (top))))
  2907. '#(syntax-object
  2908. y
  2909. (top)))))
  2910. (g00040)))
  2911. g00038)
  2912. (g00040)))
  2913. (syntax-dispatch
  2914. g00039
  2915. '(pair (any)
  2916. pair
  2917. (any)
  2918. pair
  2919. (each any)
  2920. pair
  2921. (pair (any)
  2922. pair
  2923. (any)
  2924. pair
  2925. (any)
  2926. atom)
  2927. each
  2928. pair
  2929. (any)
  2930. pair
  2931. (any)
  2932. each
  2933. any)
  2934. (vector))))
  2935. (lambda ()
  2936. (syntax-error
  2937. g00039))))
  2938. g00036))))
  2939. g00033))))
  2940. g00030))))
  2941. x)))))))
  2942.